home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / p-record.scm < prev    next >
Encoding:
Text File  |  1991-10-11  |  5.2 KB  |  182 lines
  1. ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2. ; File record.scm / Copyright (c) 1989 Jonathan Rees / See file COPYING
  3.  
  4. ;;;; Record package for Pseudoscheme
  5.  
  6. (lisp:defstruct (record-type-descriptor (:constructor make-rtd)
  7.                     (:print-function print-rtd)
  8.                     (:conc-name "RTD-"))
  9.   identification
  10.   unique-id
  11.   field-names
  12.   constructor-function
  13.   predicate-function
  14.   accessor-functions)
  15.  
  16. (define *record-type-unique-id* 0)
  17.  
  18. (define package-for-record-functions
  19.   (lisp:make-package
  20.    (lisp:if (lisp:find-package ".RECORD")
  21.         (let loop ((n 0))
  22.           (let ((name (string-append ".RECORD-" (number->string n))))
  23.         (lisp:if (lisp:find-package name)
  24.              (loop (+ n 1))
  25.              name)))
  26.         ".RECORD")
  27.    :use '()))
  28.  
  29. (define (really-make-record-type type-id field-names)
  30.   (let* ((conc
  31.       (lambda things
  32.         (lisp:intern
  33.          (apply string-append
  34.             (map (lambda (thing)
  35.                (cond ((string? thing) thing)
  36.                  ((number? thing)
  37.                   (number->string thing))
  38.                  ((symbol? thing)
  39.                   (lisp:symbol-name thing))
  40.                  (else "?")))
  41.              things))
  42.          package-for-record-functions)))
  43.      (id-symbol
  44.       (conc type-id "#" *record-type-unique-id*))
  45.      (constructor-function
  46.       (conc 'make- id-symbol))
  47.      (predicate-function
  48.       (conc id-symbol '?))
  49.      (accessor-functions
  50.       (map (lambda (f)
  51.             (conc id-symbol '- f))
  52.            field-names))
  53.      (rtd (make-rtd :identification type-id
  54.             :unique-id *record-type-unique-id*
  55.             :field-names field-names
  56.             :constructor-function constructor-function
  57.             :predicate-function predicate-function
  58.             :accessor-functions accessor-functions)))
  59.     (lisp:setf (lisp:get id-symbol 'rtd) rtd)
  60.     (let ((lisp:*package* package-for-record-functions))
  61.       ;; Careful -- :CONC-NAME NIL doesn't mean defstruct won't try to
  62.       ;; intern new symbols in current package!
  63.       (lisp:eval `(lisp:defstruct (,id-symbol
  64.                    (:constructor ,constructor-function ())
  65.                    (:print-function ,(lisp:quote print-record))
  66.                    (:predicate ,predicate-function)
  67.                    (:copier lisp:nil)
  68.                    (:conc-name lisp:nil))
  69.             ,@accessor-functions)))
  70.     (set! *record-type-unique-id* (+ *record-type-unique-id* 1))
  71.     rtd))
  72.  
  73. (define (record-constructor rtd . init-names-option)
  74.   (let ((cfun (rtd-constructor-function rtd))
  75.     (funs (map (lambda (name)
  76.              (rtd-accessor-function rtd name))
  77.            (if (null? init-names-option)
  78.                (rtd-field-names rtd)
  79.                (car init-names-option)))))
  80.     (lisp:unless (lisp:compiled-function-p (lisp:symbol-function cfun))
  81.          (lisp:compile cfun))
  82.     (lisp:compile 'lisp:nil
  83.           `(lisp:lambda ,funs
  84.              (lisp:let ((the-record (,cfun)))
  85.                ,@(map (lambda (fun)
  86.                 `(lisp:setf (,fun the-record)
  87.                         ,fun))
  88.                   funs)
  89.                the-record)))))
  90.  
  91. (define (record-predicate rtd)
  92.   (let ((fun (rtd-predicate-function rtd)))
  93. ;    (lisp:unless (lisp:compiled-function-p (lisp:symbol-function fun))
  94. ;                 (lisp:compile fun))
  95. ;    (lisp:symbol-function fun)
  96.     (lisp:compile 'lisp:nil
  97.           `(lisp:lambda (x)
  98.              (schi:true? (,fun x))))))
  99.  
  100. (define (record-accessor rtd name)
  101.   (let ((fun (rtd-accessor-function rtd name)))
  102.     (lisp:unless (lisp:compiled-function-p (lisp:symbol-function fun))
  103.          (lisp:compile fun))
  104.     (lisp:symbol-function fun)))
  105.  
  106. (define (record-modifier rtd name)
  107.   (let ((fun (rtd-accessor-function rtd name)))
  108.     (lisp:compile 'lisp:nil `(lisp:lambda (x y)
  109.                    (lisp:setf (,fun x) y)))))
  110.  
  111. (define (rtd-accessor-function rtd name)
  112.   (let loop ((l (rtd-field-names rtd))
  113.          (a (rtd-accessor-functions rtd)))
  114.     (if (null? l)
  115.     (lisp:error "~S is not a field name for ~S records"
  116.             name
  117.             (rtd-identification rtd))
  118.     (if (eq? name (car l))
  119.         (car a)
  120.         (loop (cdr l) (cdr a))))))
  121.  
  122. ; make-record-type:
  123.  
  124. (define record-type-table (lisp:make-hash-table :test 'lisp:equal))
  125.  
  126. (define (make-record-type type-id field-names)
  127.   (let* ((key (cons type-id field-names))
  128.      (existing (lisp:gethash key record-type-table)))
  129.     (if (and (not (eq? existing 'lisp:nil))
  130.          (begin (lisp:format lisp:*query-io*
  131.                  "~&Existing ~S has fields ~S.~%"
  132.                  existing
  133.                  field-names)
  134.             (not (eq?
  135.               (lisp:y-or-n-p
  136.                "Use that descriptor (instead of creating a new one)? ")
  137.               'lisp:nil))))
  138.     existing
  139.     (let ((new (really-make-record-type type-id field-names)))
  140.       (lisp:setf (lisp:gethash key record-type-table) new)
  141.       new))))
  142.  
  143. (define (record-type record)
  144.   (lisp:get (lisp:type-of record) 'rtd))
  145.  
  146. ; Printing
  147.  
  148. (define (print-rtd rtd stream escape?)
  149.   escape? ;ignored
  150.   (lisp:format stream
  151.            "#{Record-type-descriptor ~S.~S}"
  152.            (rtd-identification rtd)
  153.            (rtd-unique-id rtd)))
  154.  
  155. (define (print-record record stream escape?)
  156.   escape?                ;ignored
  157.   (let ((d (disclose-record record)))
  158.     (display "#{")
  159.     (display (if (symbol? (car d))
  160.              (lisp:string-capitalize (symbol->string (car d)))
  161.              (car d))
  162.          stream)
  163.     (for-each (lambda (x)
  164.         (write-char #\space stream)
  165.         (write x stream))
  166.           (cdr d))
  167.     (display "}")))
  168.  
  169. (define record-disclosers (lisp:make-hash-table))
  170.  
  171. (define (disclose-record record)
  172.   ((lisp:gethash (record-type record)
  173.          record-disclosers
  174.          default-record-discloser)
  175.    record))
  176.  
  177. (define (default-record-discloser record)
  178.   (list (rtd-identification (record-type record))))
  179.  
  180. (define (define-record-discloser rtd proc)
  181.   (lisp:setf (lisp:gethash rtd record-disclosers) proc))
  182.